home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d27 / chkobjex.arc / CPP1520.RPG < prev    next >
Text File  |  1991-12-04  |  6KB  |  143 lines
  1.      F/TITLE     DISPLAY A FILE'S RECORD FORMAT
  2.      F*          PROGRAM NAME - CPP1520
  3.      F*          CPP FOR COMMAND - DSPRCDFMT
  4.      F*
  5.      FCPP1520 CF  E                    WORKSTN      KINFDS WSDS
  6.      F                                        RRN   KSFILE CPP1520D
  7.      FQADSPFFDIF  E                    DISK                           UC
  8.      E                    FL         21  1               FILENAME WORK ARR
  9.      E                    D      80 160  1               DSPFFD COMMAND
  10.      IFILE        DS
  11.      I                                        1  10 FNAME
  12.      I                                       11  20 FLIB
  13.      IWSDS        DS
  14.      I                                    B 378 3790SFREC
  15.      C           *ENTRY    PLIST
  16.      C                     PARM           FILE
  17.      C/SPACE
  18.      C*  BUILD FILE NAME FOR CALL TO QCAEXEC
  19.      C                     MOVEAFNAME     FL,1
  20.      C                     Z-ADD1         X       50
  21.      C           ' '       LOKUPFL,X                     98
  22.      C                     MOVE '.'       FL,X
  23.      C                     ADD  1         X
  24.      C                     MOVEAFLIB      FL,X
  25.      C*  PLACE FILE,LIBRARY NAME INTO DSPFFD COMMAND ARRAY
  26.      C                     MOVEAFL        D,11
  27.      C* EXECUTE THE DSPFFD COMMAND VIA QCAEXEC
  28.      C                     MOVEAD         CMD    80
  29.      C                     CALL 'QCAEXEC'              97  IF 97 RETURN
  30.      C                     PARM           CMD
  31.      C                     PARM 80        LENGTH 155
  32.      C/SPACE
  33.      C*  IF AND ERROR OCCURED WHILE EXECUTING THE
  34.      C*  DSPFFD COMMAND, THEN RETURN TO THE CALLER
  35.      C           *IN97     CABEQ'1'       EXIT
  36.      C/SPACE
  37.      C*  SET ON FIRST CALL FLAG
  38.      C                     MOVEL'1'       FIRST   1
  39.      C*  EXECUTE OVERRIDE DATABASE FILE COMMAND
  40.      C                     MOVEAD,81      CMD
  41.      C                     EXSR EXECMD
  42.      C/SPACE
  43.      C*  OPEN THE WORKFILE
  44.      C                     OPEN QADSPFFD               97  IF 97 RETURN
  45.      C/SPACE
  46.      C*  IF AND ERROR OCCURED DURING OPEN
  47.      C*  THEN RETURN TO THE CALLER
  48.      C           *IN97     CABEQ'1'       EXIT
  49.      C/SPACE
  50.      C*  ACTIVATE THE SUBFILE FILE
  51.      C*  (NOTE AT HIS POINT *IN21 IS EQUAL TO ZERO)
  52.      C           CLRSFL    TAG
  53.      C                     MOVEL'0'       *IN21
  54.      C                     WRITECPP1520C
  55.      C                     Z-ADD0         RRN     50
  56.      C/SPACE
  57.      C*  READ WORKFILE AND FILL UP SUBFILE
  58.      C           READWF    TAG
  59.      C                     READ QADSPFFD                 96EOF = 96
  60.      C           *IN96     IFEQ '0'
  61.      C                     MOVEL'0'       *IN05
  62.      C           FIRST     IFEQ '1'
  63.      C                     MOVELWHNAME    LSTRCD
  64.      C                     END
  65.      C*  COMPARE THIS RECORD FORMAT TO THE LAST FORMAT.
  66.      C*  IF THE RECORD FORMATS MATCH THEN PROCESS RECORD.
  67.      C           WHNAME    IFEQ LSTRCD
  68.      C                     MOVEL'0'       FIRST
  69.      C*  BUILD FIELD FROM-TO POSITIONS
  70.      C           WHIBO     ADD  WHFLDB    FLDTO
  71.      C                     SUB  1         FLDTO
  72.      C                     Z-ADDWHIBO     FLDFRM
  73.      C*  BUILD FIELD LENGTH ATTRIBUTE
  74.      C           WHFLDT    IFEQ 'A'
  75.      C                     MOVE WHFLDB    LEN
  76.      C                     ELSE
  77.      C                     MOVELWHFLDD    LEN
  78.      C                     MOVE '   '     LEN
  79.      C                     MOVE WHFLDP    LEN
  80.      C                     END
  81.      C*  INCREMENT SUBFILE RELATIVE RECORD NUMBER
  82.      C                     ADD  1         RRN
  83.      C*  WRITE SUBFILE RECORD
  84.      C                     WRITECPP1520D
  85.      C*  BRANCH BACK TO READ
  86.      C                     GOTO READWF
  87.      C                     ELSE
  88.      C                     MOVELWHNAME    LSTRCD
  89.      C                     READPQADSPFFD               9898
  90.      C           *LIKE     DEFN WHNAME    LSTRCD
  91.      C                     END
  92.      C                     END
  93.      C/SPACE
  94.      C*  IF NO SUBFILE RECORDS HAVE BEEN WRITTEN,
  95.      C*  THEN RETURN TO THE CALLER
  96.      C           RRN       CABLT1         EXIT
  97.      C/SPACE
  98.      C*  DISPLAY THE SUBFILE CONTROL RECORD
  99.      C*  SUBFILE IS CONTROLLED BY INDICATOR 21
  100.      C                     MOVEL'1'       *IN21
  101.      C*  FILE FIELD INFORMATION WILL BE DISPLAYED UNTIL
  102.      C*  COMMAND KEY 1 IS PRESSED
  103.      C                     Z-ADD1         RECNO
  104.      C           *IN01     DOUEQ'1'
  105.      C           DSPSFL    TAG
  106.      C                     WRITECPP1520B
  107.      C                     EXFMTCPP1520C
  108.      C                     Z-ADDSFREC     RECNO
  109.      C           *IN05     CABEQ'1'       CLRSFL
  110.      C                     MOVE '0'       *IN93
  111.      C           READC     TAG
  112.      C                     READCCPP1520D                 93
  113.      C           *IN93     IFEQ '0'
  114.      C           OPT       IFEQ '1'
  115.      C                     MOVEL' '       OPT
  116.      C                     UPDATCPP1520D
  117.      C                     EXFMTCPP1520I
  118.      C           *IN01     CABEQ'1'       EXIT
  119.      C           *IN02     CABEQ'1'       DSPSFL
  120.      C                     END
  121.      C           OPT       IFEQ '5'
  122.      C                     MOVEL' '       OPT
  123.      C                     UPDATCPP1520D
  124.      C                     MOVEL*BLANKS   CMD
  125.      C                     MOVEL'DSPFLDWU'CMD    80
  126.      C                     MOVE WHFLDE    CMD
  127.      C                     EXSR EXECMD
  128.      C                     END
  129.      C                     GOTO READC
  130.      C                     END
  131.      C                     END
  132.      C           EXIT      TAG
  133.      C                     MOVEL'1'       *INLR
  134.      CSR         EXECMD    BEGSR
  135.      C*  EXECUTE THE COMMAND STRING
  136.      C                     CALL 'QCAEXEC'
  137.      C                     PARM           CMD
  138.      C                     PARM 80        LENGTH
  139.      CSR                   ENDSR
  140. **
  141. DSPFFD                          OUTPUT(*NONE) OUTFILE(QADSPFFD.QTEMP)
  142. OVRDBF QADSPFFD TOFILE(QADSPFFD.QTEMP)
  143.